(ns com.richrail.core
  (:use clojure.contrib.monads)
  (:use clojure.contrib.trace)
  (:use clojure.contrib.str-utils))

(defmonad log-m
          [m-result (fn [x] [x, []])
           m-bind   (fn [[v l] f] 
                      (let [[v- l-] (f v)] 
                        [v- (concat l l-)]))])

(def depot (atom [(list) (list)]))
(def wagons first)
(def trains second)
(def obj-id (comp val first))

(defn- make-id-generator [prefix]
  (let [counter (atom 0)] #(str prefix (swap! counter inc))))
(def generate-train-id (make-id-generator "tr"))
(def generate-wagon-id (make-id-generator "wg"))

(def select {:trains trains :wagons wagons})
(def other  {:trains wagons :wagons trains})
(def order  {:trains partial :wagons (fn [f x] (fn [y] (f y x)))})
(def free-bool {:free true :connected false})
(def exists? {:yes identity :no not})

(defn find-object [obj-type depot id]
  (first (filter (fn [x] (= (obj-id x) id)) (obj-type depot))))

(defn- free-wagons [depot]
  (filter (comp free-bool :status) (wagons depot)))

(defn- apply-to-id-only [coll id f]
  (map (fn [x] (if (= (obj-id x) id)
                   (f x)
                    x)) 
        coll))

(defn- try-if-exists [exist id f error]
  (fn [coll]
    (if ((exists? exist) (some (comp (partial = id) obj-id) coll))
      (f coll)
      [coll [(str "> " error)]])))

(defn- new-train [id]
  (try-if-exists :no id
    (fn [coll] [(cons {:train id :twagons (list)} coll) [(str "> train " id " created")]])
    (str "no train created, " id " exists!")))

(defn- new-wagon [id & arg]
  (try-if-exists :no id
    (fn [coll] (let [seats (if (nil? (first arg)) 20 (first arg))]
        [(cons {:wagon id :seats seats :status :free} coll) [(str "> wagon " id " created")]]))
    (str "no wagon created, " id " exists!")))

(defn- get-train [id]
  (try-if-exists :yes id
    (fn [coll] 
      [coll [(str "> number of seats in train " id ": "
                  (apply + (map (fn [x] (:seats (find-object wagons @depot x)))
                                (:twagons (find-object trains @depot id)))))]])
    (str "train " id " does not exist!")))

(defn- set-wagon [id is-free]
  (try-if-exists :yes id 
    (fn [coll] [(apply-to-id-only coll id (fn [wagon] (assoc wagon :status is-free))) [(str "> wagon " id " is now " (name is-free))]])
    (str "I cannot alter " id " for it does not exist!")))

(defn- wagon-to-train [wagon-id train-id]
  (try-if-exists :yes train-id
    (fn [coll] [(apply-to-id-only coll train-id 
      (fn [train] (assoc train :twagons (distinct (conj (:twagons train) wagon-id)))))
                [(str "> " wagon-id " added to " train-id)]])
      (str "no wagons can be added to " train-id " for it does not exist!")))

(defn- wagon-from-train [wagon-id train-id]
  (try-if-exists :yes train-id
    (fn [coll] [(apply-to-id-only coll train-id 
      (fn [train] (assoc train :twagons (remove (partial = wagon-id) (:twagons train)))))
                [(str "> " wagon-id " removed from " train-id)]])
      (str "no wagons can be removed from " train-id " for it does not exist!")))

(defn- get-wagon [id]
  (try-if-exists :yes id
    (fn [coll] [coll [(str "> number of seats in wagon " id " : " (:seats (find-object wagons @depot id)))]])
    (str "wagon " id " does not exist")))

(defn- del-vehicle [id]
  (try-if-exists :yes id
    (fn [coll] [(remove (comp (partial = id) obj-id) coll) [(str  "> " id " deleted")]])
      (str id " not deleted, it wasn't there to begin with!")))

(defn- connected-train [wagon-id]
  (if (= (:status (find-object wagons @depot wagon-id)) :free)
    nil
    (some (fn [t] (if (seq (some #{wagon-id} (:twagons t))) (obj-id t))) (trains @depot))))
    

(defn- release-wagons [id]
  (let [twagons ((find-object trains @depot id) :twagons)]
    (fn [ws] [(map (fn [w] (if (some #{(obj-id w)} twagons)
                            (assoc w :status :free)
                             w)) ws) [(str "wagons released from " id)]])))

(defn- do-to [obj-type func]
  (fn [depot]
    (let [selected (func ((select obj-type) depot))
          others         ((other obj-type) depot)]
    (with-monad log-m
      (m-bind selected (comp m-result ((order obj-type) vector others )))))))

(def in-trains (partial do-to :trains))
(def in-wagons (partial do-to :wagons))

(defn- do-to-both [wfunc tfunc]
  (fn [depot]
      (with-monad log-m
        ((m-chain [(in-trains tfunc) (in-wagons wfunc)]) depot))))

(def in-both do-to-both)

(defn- modify! [at funcs]
  (let [action  (with-monad log-m (m-chain funcs))
        [_ msg] (action @at)]
    (swap! at (comp first action))
    (doseq [msg msg] (println msg))
    (str-join "\n" msg)))

(defn- new-wagon-cmd [id & seats] (in-wagons (new-wagon id (first seats))))
(defn- new-train-cmd [id] (in-trains (new-train id)))
(defn- get-wagon-cmd [id] (in-wagons (get-wagon id)))
(defn- get-train-cmd [id] (in-trains (get-train id)))

(defn- add-wagon-to-train-cmd [wid tid]
  (in-both (set-wagon wid :connected) (wagon-to-train wid tid)))

(defn- remove-wagon-from-train-cmd [wid tid]
  (in-both (set-wagon wid :free) (wagon-from-train wid tid)))

(defn- del-wagon-cmd [id]
  (in-both (del-vehicle id) (let [train-id (connected-train id)]
                              (if (not (nil? train-id))
                                (wagon-from-train id train-id)))))

(defn- del-train-cmd [id]
  (in-both (release-wagons id) (del-vehicle id)))

(defn- print-wagon [wagon]
  (str "-[WAGON " (obj-id wagon) " | " (:seats wagon) " seats" "]<" (:status wagon) ">" ))

(defn- print-train [train]
  (str "-[TRAIN " (obj-id train) "]" 
    (if (seq (:twagons train))
      (apply str (map (comp print-wagon (partial find-object wagons @depot)) 
                      (:twagons train))))))

(defn print-depot [depot]
  (str "[30m+----------------------------------------------------------+\n"
       "| [30;1m[20G=== Losse wagons: ===[0;30m[60G|\n"
       "[30m+----------------------------------------------------------+\n"
       "" (apply str (interpose "[60G\n " 
              (map print-wagon (free-wagons @depot)))) "[60G\n\n"
       "+----------------------------------------------------------+\n"
       "| [30;1m[22G=== Treinen: ===[0;30m[60G|\n"
       "[30m+----------------------------------------------------------+\n\n"
       "" (apply str (interpose "[60G\n" (map print-train (trains @depot)))) "[60G\n"
       ;"+----------------------------------------------------------+\n"
       "\n[37;0m"))

(def parser-m (state-t maybe-m))

(defn- any-char [strn]
      (if (= "" strn)
          nil
          (list (first strn) (. strn (substring 1)))))

(defn- char-test [pred]
      (domonad parser-m
               [c any-char
                :when (pred c)]
               (str c)))

(defn- is-char [c]
      (char-test (partial = c)))

(defn- match-string [target-strn]
  (with-monad parser-m
      (if (= "" target-strn)
          (m-result "")
          (domonad parser-m
                   [c (is-char (first target-strn))
                    cs (match-string (apply str (rest target-strn)))]
                   (str c cs)))))

(defn- match-chars [target-chars]
          (domonad parser-m
                   [c (char-test (fn [x] (some #{x} target-chars)))
                    cs (m-plus (match-chars target-chars) (m-result ""))]
                   (str c cs)))

(defn- optional [parser]
      (with-monad parser-m (m-plus parser (m-result nil) )))

(defn- both [a b]
  (domonad parser-m
    [ar a
     br b]
  (str ar br)))

(def whitespace (match-chars " \t\n\r"))
(def number (match-chars "1234567890"))

(def type-parser
  (with-monad parser-m (m-plus (match-string "wagon") (match-string "train"))))

(def id-parser
  (domonad parser-m
    [ _       whitespace
      prefix (m-plus (match-string "wg") 
                     (match-string "tr"))
      number  number]
    (str prefix number)))

(def wagon-id-parser
  (with-monad parser-m (both (match-string "wg") number)))

(def train-id-parser
  (with-monad parser-m (both (match-string "tr") number)))

(def numseats-parser
  (domonad parser-m
    [ _     whitespace
      _     (match-string "numseats")
      _     whitespace
      seats number]
    (read-string seats)))

(def new-command-parser 
  (domonad parser-m 
    [ _        (match-string "new") 
      _         whitespace
      obj-type  type-parser
      id       (optional id-parser)
      seats    (optional numseats-parser)
     ] 
    (if (= obj-type "train")
      (fn [depot] (modify! depot [(new-train-cmd (if (nil? id) (generate-train-id) id))]))
      (let [id (if (nil? id) (generate-wagon-id) id)]
        (if (nil? seats)
          (fn [depot] (modify! depot [(new-wagon-cmd id)]))
          (fn [depot] (modify! depot [(new-wagon-cmd id seats)])))))))

(def add-command-parser 
  (domonad parser-m
    [ _     (match-string "add")
      _      whitespace
      wagon  wagon-id-parser
      _      whitespace
      _     (match-string "to")
      _      whitespace
      train  train-id-parser]
    (fn [depot] (modify! depot [(add-wagon-to-train-cmd wagon train)]))))

(def get-command-parser
  (domonad parser-m
    [ _        (match-string "getnumseats")
      _         whitespace
      obj-type  type-parser 
      id        id-parser]
    (if (= obj-type "train")
        (fn [depot] (modify! depot [(get-train-cmd id)]))
        (fn [depot] (modify! depot [(get-wagon-cmd id)])))))

(def delete-command-parser
  (domonad parser-m
    [ _        (match-string "delete")
      _         whitespace
      obj-type  type-parser
      id        id-parser ]
    (if (= obj-type "train")
        (fn [depot] (modify! depot [(del-train-cmd id)]))
        (fn [depot] (modify! depot [(del-wagon-cmd id)])))))

(def remove-command-parser
  (domonad parser-m
    [ _        (match-string "remove")
      _         whitespace
      wagon     wagon-id-parser
      _         whitespace
      _        (match-string "from")
      _         whitespace
      train     train-id-parser]
    (fn [depot] (modify! depot [(remove-wagon-from-train-cmd wagon train)]))))

(def print-command-parser
  (domonad parser-m
    [ _ (match-string "print") ]
    (comp println print-depot)))

(def parse-command
  (with-monad parser-m (m-plus add-command-parser new-command-parser get-command-parser delete-command-parser remove-command-parser print-command-parser)))

(defn do-evaluate [string]
  (eval ((first (parse-command string)) depot)))

(defn repl []
  (print "# ")(flush)
  (let [input (read-line)]
    (if (not (= input "quit"))
        (do (do-evaluate input)
            (recur)))))

(defn- test-core []
  (do
    (do-evaluate "new train")
    (do-evaluate "new train tr1")
    (do-evaluate "new wagon")
    (do-evaluate "new wagon wg1")
    (do-evaluate "print")
    (do-evaluate "add wg1 to tr1")
    (do-evaluate "add wg1 to tr1")
    (do-evaluate "print")
    (do-evaluate "remove wg1 from tr1")
    (do-evaluate "remove wg1 from tr1")
    (do-evaluate "print")))
